#!/bin/bash

# LISP SHLISP
# Shlisp is a toy lisp, implemented in pure Bash, created for my own amusement.
#
#
# Copyright (C) 2012 Mattias Slabanja <don.fanucci@gmail.com>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

if (( (BASH_VERSINFO[0] < 4) || ((BASH_VERSINFO[0] == 4) && (BASH_VERSINFO[1] < 2)) )); then
    echo "Bash version >= 4.2 required."
    exit
fi

# Using a little bit of Hungarian notation for references and such
TYPE_CONS=C          # C... - Cons cell
TYPE_INT=I           # I... - Int (directly inscribed in ref)
TYPE_STRING=S        # S... - String
TYPE_FUNCTION=F      # F... - Function/lambda
TYPE_BI_FUNCTION=f   # f... - Builtin function
TYPE_MACRO=M         # M... - Macro
TYPE_SPECIAL=P       # P... - Special builtin operator
TYPE_SYMBOL=Y        # Y... - Symbol (directly inscribed in ref)
TYPE_GENSYMBOL=G     # G... - Generated symbol (directly inscribed in ref)

PREF_ENVIRONMENT=ENV # Environment
PREF_RETVAR=RV       # Return variable name prefix (internal use)

SYMB_T=T
SYMB_NIL=nil
SYMB_QUOTE=quote
SYMB_BACKQUOTE=-backquote-
SYMB_COMMA=-bq-comma-
SYMB_COMMA_AT=-bq-comma-at-

IFS=" "
unset objects outer_environment
declare -i _index=0
declare -A objects outer_environment reference_counter

set -f
shopt -s expand_aliases

_debug=false
_interactive=false
while getopts ":hdi" optchar; do
    [[ -n $OPTARG ]] && continue
    case $optchar in
        d ) _debug=true ;;
        i ) _interactive=true ;;
        h ) echo "Usage: shlisp [-h] [-d] [-i] [FILE] ...

  -h     Show command line options
  -d     Show internal information, such as a backtrace upon errors
  -i     Launch interactive read-eval-print-loop (default if no files specified)
"
            exit
            ;;
    esac
    set -- "${@:1:$((OPTIND-2))}" "${@:$((OPTIND))}"
    ((OPTIND--))
done

alias _arity_error='{ _set_error "wrong number of arguments"; return 1; }'
alias _general_error='{ _set_error "error"; return 1; }'
_clear_error () { _error_trace=(); }
_clear_error
_show_error () {
    local t i emsg=""
    for ((i = $((${#_error_trace[@]} - 1)); i >= 0; i--)); do
        t=( ${_error_trace[$i]} )
        if $_debug; then
            printf "%3i: %s\n" $i "${t[*]}"
        elif ((${#t[@]} > 2)); then
            emsg="${emsg}  - ${t[@]:2}\n"
        fi
    done
    echo -n -e "$emsg"
    _clear_error
}
_set_error () {
    local emsg=$1 ind=0 bt
    if ((${#_error_trace[@]} == 0)); then
        while bt=( $(caller $ind) ); do
            _error_trace[$((ind++))]=${bt[*]:0:2}
        done
    else
        while caller $((ind++)) >/dev/null; do :; done
        ((ind--))
    fi
    ((ind = ${#_error_trace[@]} - ind))
    _error_trace[$ind]="${_error_trace[$ind]}: $emsg"
}

exist () { [[ ${!1+X} ]]; }
collect () {
    # Unset objects not being referred to
    unset IFS # compgen returns newline separated items
    local -i aggregated=0 objects_collected i
    for ((i=0; i < 10; i++)); do
        ((objects_collected=0))
        for o in $(compgen -v ${PREF_ENVIRONMENT}) ${!objects[@]}; do
            if ((${reference_counter[$o]:-0} == 0)); then
                collect_object $o
                ((objects_collected += 1))
            fi
        done
        if ((objects_collected == 0)); then
            break
        fi
        ((aggregated += objects_collected))
    done
    if $_debug && ((aggregated > 0)); then
        printf "(%i objects colleted)\n" $aggregated
    fi
    IFS=" "
}
collect_object () {
    # object=$1
    local object=$1
    case $object in
        ${PREF_ENVIRONMENT}* )
            collect_environment $object
            ;;
        ${TYPE_CONS}* )
            collect_cons $object
            ;;
        ${TYPE_FUNCTION}* | ${TYPE_MACRO}* )
            collect_lambda_or_macro $object
            ;;
        ${TYPE_STRING}* )
            unset objects[$object]
            unset reference_counter[$object]
            ;;
    esac
}
get_object () {
    # retvar=$1 current_env=$2 symbol=$3
    local retvar=$1 current_env=$2 symbol=$3
    find_containing_environment $retvar $current_env "${symbol}" || {
        _set_error "Symbol $(_print "${symbol}") has no value"
        return 1
    }
    eval $retvar=\"\${${!retvar}[${symbol}]}\"
}
bind_symbol () {
    # current_env=$1 symbol="$2" object=$3
    local current_env=$1 symbol=$2 object=$3
    eval ${current_env}[${symbol}]=\"${object}\"
    ((reference_counter[$object] += 1))
}
collect_cons () {
    # cons=$1
    local cons=$1 car cdr
    read car cdr <<< ${objects[$cons]}
    ((reference_counter[$car] -= 1))
    ((reference_counter[$cdr] -= 1))
    unset objects[$cons]
    unset reference_counter[$cons]
}
create_cons () {
    # retvar=$1 car=$2 cdr=$3
    local retvar=$1 car=$2 cdr=${3:-${TYPE_SYMBOL}${SYMB_NIL}} object=${TYPE_CONS}$((_index++))
    objects[${object}]="${car} ${cdr}"
    eval $retvar=${object}
    ((reference_counter[$car] += 1))
    ((reference_counter[$cdr] += 1))
}
set_car () {
    # cons=$1 car=$2
    local cons=$1 car=$2 ocar cdr
    read ocar cdr <<< ${objects[$cons]}
    objects[$cons]="${car} ${cdr}"
    ((reference_counter[$ocar] -= 1))
    ((reference_counter[$car] += 1))
}
set_cdr () {
    # cons=$1 cdr=$2
    local cons=$1 cdr=$2 ocdr car
    read car ocdr <<< ${objects[$cons]}
    objects[$cons]="${car} ${cdr}"
    ((reference_counter[$ocdr] -= 1))
    ((reference_counter[$cdr] += 1))
}
create_string () {
    # retvar=$1 str=$2
    local retvar=$1 str=$2 t
    t=${TYPE_STRING}$((_index++))
    objects[$t]="${str}"
    eval $retvar=$t
}
collect_lambda_or_macro () {
    # lambda=$1
    local lambda=$1 env vars body
    read env _ _ vars body <<< ${objects[$lambda]}
    ((reference_counter[$env] -= 1))
    ((reference_counter[$vars] -= 1))
    ((reference_counter[$body] -= 1))
    unset objects[$lambda]
    unset reference_counter[$lambda]
}
_args_length () {
    # "retvar=$1" $object=$2
    local retvar=$1 object=$2 s tail i=0
    tail=$object
    while consp $tail; do
        read s tail <<< ${objects[$tail]}
        symbolp $s || { _set_error "$(_print "$s") is not a symbol"; return 1; }
        ((i++))
    done
    if null $tail; then
        eval $retvar="'== $i'"
    elif symbolp $tail; then
        eval $retvar="'>= $i'"
    else
        _set_error "$(_print $object) is neither list, dotted list, or symbol"; return 1
    fi
}
create_lambda_or_macro () {
    # retvar=$1 env=$2 vars=$3 body=$4 type=$5
    local retvar=$1 env=$2 vars=$3 body=$4 type=${5} arity t
    _args_length $retvar $vars || return $?
    arity=${!retvar}
    t=${type}$((_index++))
    objects[$t]="$env $arity $vars $body"
    eval $retvar=$t
    ((reference_counter[$env] += 1))
    ((reference_counter[$vars] += 1))
    ((reference_counter[$body] += 1))
}
find_containing_environment () {
    # retvar=$1 current_env=$2 symbol=$3
    local retvar=$1 current_env=$2 symbol=$3
    while [[ -n $current_env ]]; do
        if exist "$current_env[${symbol}]"; then
            eval $retvar=$current_env
            return
        fi
        current_env=${outer_environment[$current_env]}
    done
    return 1
}
collect_environment () {
    # $1=env
    local env=$1 x=${1}[@] o
    for o in ${!x}; do
        ((reference_counter[$o] -= 1))
    done
    o=outer_environment[$env]
    ((reference_counter[$o] -= 1))
    unset outer_environment[$env]
    unset $env
}
create_environment () {
    # retvar=$1 outer_env=$2
    local retvar=$1 outer_env=$2 e
    e=${PREF_ENVIRONMENT}$((_index++))
    unset $e
    declare -g -A $e
    if [[ -n $outer_env ]]; then
	((reference_counter[$outer_env] += 1))
        eval outer_environment[$e]=$outer_env
    fi
    eval $retvar=$e
}
tokenize () {
    # Read from stdin, write tokens to stdout
    while read -e -r line; do
        if [[ $line =~ ^([^\;]*)\;.*$ ]]; then
            line="${BASH_REMATCH[1]}"
        fi
        while ! [[ $line =~ ^\ *$ ]]; do
            [[
            # Match opening (
                $line =~ ^\ *(\()(.*)$  ||
            # Match closing )
                $line =~ ^\ *(\))(.*)$  ||
            # Match quote/backquote/unquote-at/unquote
                $line =~ ^\ *(\'|\`|,@|,)(.*)$  ||
            # Match string (doesn't handle escaped ")
                $line =~ ^\ *([,@\`\']*\"[^\"]*\")(\ .*|\).*|.{0})$  ||
            # Match symbol or number
                $line =~ ^\ *([,@\`\']*[a-zA-Z0-9^#.\!?_~\<\>=|/*+-]+)(\ .*|\).*|.{0})$
            # or fail
            ]] || return 1
            m="${BASH_REMATCH[1]}"
            line="${BASH_REMATCH[2]}"
            printf "%s\n" "$m"
        done
    done
}
discard_tokens () { while read -t 0.001; do :; done; }
read_tokens () {
    # revar=$1 [token="$2"]
    local retvar=$1 token=$2 head pre t
    if [[ -z $token ]]; then
        read token
        [[ -n $token ]] || return 1
    fi

    if [[ ${token} =~ ^(\'|\`|,) ]]; then
        case ${token} in
            \' ) t=${SYMB_QUOTE} ;;
            \` ) t=${SYMB_BACKQUOTE} ;;
            , )  t=${SYMB_COMMA} ;;
            ,@ ) t=${SYMB_COMMA_AT} ;;
            * ) { _set_error "invalid quote construction"; return 1; }
        esac
        read_tokens $retvar || return $?
        create_cons $retvar ${!retvar} || return $?
        create_cons $retvar ${TYPE_SYMBOL}${t} ${!retvar} || return $?
    elif [[ $token =~ ^\"([^\"]*)\"$ ]]; then
        create_string $retvar "${BASH_REMATCH[1]}" || return $?
    elif [[ $token =~ ^-?[0-9]+$ ]]; then
        eval $retvar=${TYPE_INT}$token
    elif [[ $token == '(' ]]; then
        while true; do
            read token
            [[ -n $token ]] || { _set_error "Expected token"; return 1; }
            if [[ $token == ')' ]]; then
                [[ -z $head ]] && head=${TYPE_SYMBOL}${SYMB_NIL}
                break
            elif [[ $token == '.' ]]; then
                [[ -n $head ]] || { _set_error "list can't start with dot"; return 1; }
                read token
                [[ $token != ')' ]] || { _set_error "list can't end with dot"; return 1; }
                read_tokens $retvar "$token" || return $?
                read token
                [[ $token == ')' ]] || { _set_error "malformed dotted list"; return 1; }
                set_cdr $pre ${!retvar}
                break
            else
                read_tokens $retvar "$token" || return $?
                create_cons $retvar ${!retvar} || return $?
                [[ -n $head ]] && set_cdr $pre ${!retvar} || head=${!retvar}
                pre=${!retvar}
            fi
        done
        eval $retvar=$head
    elif [[ $token =~ ^[a-zA-Z^#.\!?_~\<\>=|/*+-]+ ]]; then
        eval $retvar=\"${TYPE_SYMBOL}$token\"
    else
        _set_error "token $token is not a valid object"; return 1
    fi
}
atom () {
    # object=$1
    [[ ${1:0:1} != ${TYPE_CONS} ]]
}
consp () {
    # object=$1
    [[ ${1:0:1} == ${TYPE_CONS} ]]
}
null () {
    # object=$1
    [[ $1 == ${TYPE_SYMBOL}${SYMB_NIL} ]]
}
_print () {
    # object=$1
    local object=$1 car cdr
    case ${object:0:1} in
        ${TYPE_CONS} )
            printf "("
            while true; do
                read car cdr <<< ${objects[$object]}
                _print $car
                if consp $cdr; then
                    object=$cdr
                    printf " "
                    continue
                elif ! null $cdr; then
                    printf " . "
                    _print $cdr
                fi
                printf ")"
                break
            done
            ;;
        ${TYPE_SYMBOL} | ${TYPE_INT} )
            printf "%s" ${object:1}
            ;;
        ${TYPE_STRING} )
            printf '"%s"' "${objects[$object]}"
            ;;
        * )
            printf "<%s>" "${object}"
            ;;
    esac
}
print () { echo "$(_print $1)"; }
functionp () {
    [[ ${1:0:1} == ${TYPE_BI_FUNCTION} || ${1:0:1} == ${TYPE_FUNCTION} ]]
}
macro () { [[ ${1:0:1} == ${TYPE_MACRO} ]]; }
special () { [[ ${1:0:1} == ${TYPE_SPECIAL} ]]; }
integerp () { [[ ${1:0:1} == ${TYPE_INT} ]]; }
symbolp () {
    [[ ${1:0:1} == ${TYPE_SYMBOL} || ${1:0:1} == ${TYPE_GENSYMBOL} ]]
}
listp () {
    # object=$1
    local cons=$1 car
    while consp $cons; do
        read car cons <<< ${objects[$cons]}
    done
    null $cons || return 1
}
call_lambda () {
    # retvar=$1 lambda=$2 args=$3
    local retvar=$1 lambda=$2 args=$3 env aop arity var vars body arg
    read env aop arity vars body <<< ${objects[$lambda]}
    _check_arity $args $aop $arity || _arity_error
    create_environment $retvar $env
    env=${!retvar}
    while consp $vars; do
        read arg args <<< ${objects[$args]}
        read var vars <<< ${objects[$vars]}
        bind_symbol $env $var $arg
    done
    if [[ $aop == '>=' ]]; then
        bind_symbol $env $vars $args
    fi
    sp_progn $retvar $env $body || return $?
}
call () {
    # retvar=$1 current_env=$2 callable=$3 args=$4
    local retvar=$1 current_env=$2 callable=$3 args=$4
    case ${callable:0:1} in
        ${TYPE_SPECIAL} )
            ${objects[$callable]} $retvar $current_env $args || return $?
            ;;
        ${TYPE_BI_FUNCTION} )
            ${objects[$callable]} $retvar $args || return $?
            ;;
        ${TYPE_FUNCTION} | ${TYPE_MACRO} )
            call_lambda $retvar $callable $args || return $?
            ;;
        * )
            return 1
    esac
}
eval_expr () {
    # retvar=$1 env=$2 expr=$3
    local retvar=$1 env=$2 expr=$3 head callable args prev car cdr
    if atom $expr; then
        case $expr in
            ${TYPE_INT}* | ${TYPE_STRING}* | ${TYPE_SYMBOL}${SYMB_NIL} | ${TYPE_SYMBOL}${SYMB_T} )
                eval $retvar=$expr
                ;;
            ${TYPE_SYMBOL}* | ${TYPE_GENSYMBOL}* )
                get_object $retvar $env $expr || return $?
                ;;
            * )
                _set_error ""; return 1
                ;;
        esac
    elif consp $expr; then
        read head cdr <<< ${objects[$expr]}
        if symbolp $head; then
            get_object $retvar $env $head || return $?
        elif consp $head; then
            eval_expr $retvar $env $head || return $?
        else
            _set_error "object $(_print $head) is not callable"; return 1
        fi

        callable=${!retvar}
        if functionp ${callable}; then
            if null $cdr; then
                args=${TYPE_SYMBOL}${SYMB_NIL}
            else
                prev=""
                while consp $cdr; do
                    read car cdr <<< ${objects[$cdr]}
                    eval_expr $retvar $env $car || return $?
                    create_cons $retvar ${!retvar} || return $?
                    [[ -n $prev ]] && set_cdr $prev ${!retvar} || args=${!retvar}
                    prev=${!retvar}
                done
                if ! null $cdr; then
                    _set_error "arguments can't be dotted list"; return 1
                fi
            fi
        elif special ${callable}; then
            args=$cdr
	elif macro ${callable}; then
            call $retvar $env $callable $cdr || _general_error
	    if consp ${!retvar}; then
		read car cdr <<< ${objects[${!retvar}]}
		set_car $expr $car
		set_cdr $expr $cdr
	    else
		expr=${!retvar}
	    fi
	    eval_expr $retvar $env $expr || _general_error
	    return
        else
            _general_error
        fi
        call $retvar $env $callable $args || {
            _set_error "could not evaluate $(_print $head)"; return 1
        }
    fi
}
_length () {
    # "retvar=$1" $object=$2
    local retvar=$1 object=$2 i=0
    while consp $object; do
        read _ object <<< ${objects[$object]}
        ((i++))
    done
    null $object || return 1
    eval $retvar=$i
}
_check_arity () {
    # args=$1 op=$2 arity=$3
    local args=$1 op=$2 arity=$3 i=0
    while consp $args; do
        read _ args <<< ${objects[$args]}
        ((i++))
    done
    null $args && (($i $op $arity)) || {
        _set_error "expected ${op} ${arity}, got $i"; return 1;
    }
}
bi_cons () {
    # retvar=$1 args=$2
    local retvar=$1 args=$2 a b
    _check_arity $args '==' '2' || _arity_error
    read a b <<< ${objects[$args]}
    read b _ <<< ${objects[$b]}
    create_cons $retvar $a $b
}
bi_length () {
    # retvar=$1 args=$2
    local retvar=$1 args=$2 i=0 a
    _check_arity $args '==' '1' || _arity_error
    read a _ <<< ${objects[$args]}
    case ${a} in
        ${TYPE_CONS}* )
            _length $retvar $a
            i=${!retvar}
            ;;
        ${TYPE_SYMBOL}${SYMB_NIL} )
            i=0 ;;
        ${TYPE_STRING}* )
            i=${#objects[$a]} ;;
        * )
            return 1 ;;
    esac
    eval $retvar=${TYPE_INT}${i}
}
test_single_argument () {
    # retvar=$1 args=$2 test=$3
    local retvar=$1 args=$2 test=$3 car
    _check_arity $args '==' '1' || _arity_error
    read car _ <<< ${objects[$args]}
    if $test $car; then
        eval $retvar=${TYPE_SYMBOL}${SYMB_T}
    else
        eval $retvar=${TYPE_SYMBOL}${SYMB_NIL}
    fi
}
bi_consp () { test_single_argument $1 $2 consp; }
bi_atom () { test_single_argument $1 $2 atom; }
bi_null () { test_single_argument $1 $2 null; }
bi_symbolp () { test_single_argument $1 $2 symbolp; }
binary_cmp () {
    # retvar=$1 args=$2 [test=$3]
    local retvar=$1 args=$2 test=$3 a b r
    _check_arity $args '==' '2' || _arity_error
    read a args <<< ${objects[$args]}
    read b _ <<< ${objects[$args]}
    if [[ ${a:0:1} != ${b:0:1} ]]; then
        r=${SYMB_NIL}
    elif [[ -z $test ]]; then
        [[ $a == $b ]] && r=${SYMB_T} || r=${SYMB_NIL}
    else
        integerp $a || return 1
        (( ${a:1} $test ${b:1} )) && r=${SYMB_T} || r=${SYMB_NIL}
    fi
    eval $retvar=${TYPE_SYMBOL}$r
}
bi_eq () { binary_cmp $1 $2; }
bi_lt () { binary_cmp $1 $2 '<'; }
bi_gt () { binary_cmp $1 $2 '>'; }
bi_le () { binary_cmp $1 $2 '<='; }
bi_ge () { binary_cmp $1 $2 '>='; }
nary_op () {
    # retvar=$1 args=$2 op=$3 acc=$4
    local retvar=$1 args=$2 op=$3 acc=$4 n a
    _length $retvar $args || return $?
    n=${!retvar}
    while consp $args; do
        read a args <<< ${objects[$args]}
        integerp $a || return 1
        if ((n > 1)); then
            acc=${a:1}
            n=0
            continue
        fi
        ((acc = acc ${op} ${a:1}))
    done
    eval $retvar=${TYPE_INT}$acc
}
bi_add () { nary_op $1 $2 '+' '0'; }
bi_mul () { nary_op $1 $2 '*' '1'; }
bi_sub () { nary_op $1 $2 '-' '0'; }
bi_div () { nary_op $1 $2 '/' '1'; }
car_cdr () {
    # retvar=$1 args=$2 car/cdr=$3
    local retvar=$1 args=$2 field=$3
    _check_arity $args '==' '1' || _arity_error
    read args _ <<< ${objects[$args]}
    if null $args; then
        eval $retvar=${TYPE_SYMBOL}${SYMB_NIL}
    elif consp $args; then
        if [[ $field == 'car' ]]; then
            read $retvar _ <<< ${objects[$args]}
        else
            read _ $retvar <<< ${objects[$args]}
        fi
    else
        return 1
    fi
}
bi_car () { car_cdr $1 $2 'car'; }
bi_cdr () { car_cdr $1 $2 'cdr'; }
bi_list () { eval $1=$2; }
bi_mapcar () {
    # retvar=$1 args=$2
    local retvar=$1 args=$2 callable arg prev head t
    _check_arity $args '==' '2' || _arity_error
    read callable args <<< ${objects[$args]}
    functionp $callable || return 1
    read args _ <<<  ${objects[$args]}
    if null $args; then
        eval $retvar=${TYPE_SYMBOL}${SYMB_NIL}
    else
        while consp $args; do
            read arg args <<< ${objects[$args]}
            create_cons $retvar $arg
            t=${!retvar}
            call $retvar "" $callable $t || return $?
            set_car $t ${!retvar}
            [[ -n $prev ]] && set_cdr $prev $t || head=$t
            prev=$t
        done
        eval $retvar=$head
    fi
}
bi_gensym () {
    # retvar=$1 args=$2
    local retvar=$1 args=$2
    _check_arity $args '==' '0' || _arity_error
    eval $retvar=${TYPE_GENSYMBOL}$((_index++))
}
sp_quote () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 args=$3
    _check_arity $args '==' '1' || _arity_error
    read $retvar _ <<< ${objects[$args]}
}
sp_if () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 car cdr
    _check_arity $args '==' '3' || _arity_error
    read car cdr <<< ${objects[$args]}
    eval_expr $retvar $env $car || return $?
    null ${!retvar} && read car cdr <<< ${objects[$cdr]}
    read car _ <<< ${objects[$cdr]}
    eval_expr $retvar $env $car || return $?
}
sp_and () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 a
    eval $retvar=${TYPE_SYMBOL}${SYMB_T}
    while consp $args; do
        read a args <<< ${objects[$args]}
        eval_expr $retvar $env $a || return $?
        if null ${!retvar}; then
            break
        fi
    done
}
sp_or () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 a
    eval $retvar=${TYPE_SYMBOL}${SYMB_NIL}
    while consp $args; do
        read a args <<< ${objects[$args]}
        eval_expr $retvar $env $a || return $?
        if ! null ${!retvar}; then
            break
        fi
    done
}
sp_setq () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 sym x e
    _check_arity $args '==' '2' || _arity_error
    read sym x <<< ${objects[$args]}
    symbolp $sym || return 1
    if find_containing_environment $retvar $env $sym; then
        e=${!retvar}
    else
        e=${global_env}
    fi
    read x _ <<< ${objects[$x]}
    eval_expr $retvar $env $x || return $?
    bind_symbol $e "$sym" ${!retvar}
}
_lambda_or_macro () {
    # retvar=$1 env=$2 args=$3 type=$4
    local retvar=$1 env=$2 argsbody=$3 type=$4 vars
    _check_arity $argsbody '>=' '2' || _arity_error
    read vars argsbody <<< ${objects[$argsbody]}
    create_lambda_or_macro $retvar $env "$vars" "$argsbody" $type || return $?
}
sp_lambda () {
    # retvar=$1 env=$2 args=$3
    _lambda_or_macro $1 $2 $3 ${TYPE_FUNCTION}
}
sp_macro () {
    # retvar=$1 env=$2 args=$3
    _lambda_or_macro $1 $2 $3 ${TYPE_MACRO}
}
sp_progn () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 expr
    listp "$args" || return 1
    while consp $args; do
        read expr args <<< ${objects[$args]}
        eval_expr $retvar $env "$expr" || return $?
    done
}
sp_let () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 varpair var val vars body t let_env
    _check_arity $args '>=' '2' || _arity_error
    read vars body <<< ${objects[$args]}
    create_environment $retvar $env || return $?
    let_env=${!retvar}
    while consp $vars; do
        read varpair vars <<< ${objects[$vars]}
        _check_arity "$varpair" '==' 2 || {
            _set_error "syntax error in \"$(_print "$varpair")\", expected '(symbol value)'"
            return 1
        }
        read var t <<< ${objects[$varpair]}
        symbolp $var || { _set_error "$(_print "$var") is not a symbol"; return 1; }
        read val _ <<< ${objects[$t]}
        eval_expr $retvar $env "$val" || return $?
        bind_symbol $let_env $var ${!retvar}
    done
    sp_progn $retvar $let_env $body || return $?
}
sp_while () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3 pred body t
    _check_arity $args '==' '2' || _arity_error
    read pred t <<< ${objects[$args]}
    read body _ <<< ${objects[$t]}
    while true; do
        eval_expr $retvar $env $pred || return $?
        null ${!retvar} && break
        eval_expr $retvar $env $body || return $?
    done
}
sp_eval () {
    # retvar=$1 env=$2 args=$3
    local retvar=$1 env=$2 args=$3
    _check_arity $args '==' '1' || _arity_error
    read $retvar _ <<< ${objects[$args]}
    eval_expr $retvar $env ${!retvar} || return $?
    eval_expr $retvar $env ${!retvar} || return $?
}

retvar=${PREF_RETVAR}$((_index++))
create_environment $retvar
global_env=${!retvar}

bind_symbol $global_env "${TYPE_SYMBOL}${SYMB_NIL}" "${TYPE_SYMBOL}${SYMB_NIL}"
bind_symbol $global_env "${TYPE_SYMBOL}${SYMB_T}"   "${TYPE_SYMBOL}${SYMB_T}"

for x in "bi cons"    "bi length"  "bi consp"  "bi atom"   "bi null" \
         "bi symbolp" "bi + add"   "bi - sub"  "bi * mul"  "bi / div" \
         "bi = eq"    "bi < lt"    "bi > gt"   "bi <= le"  "bi >= ge" \
         "bi eq eq"   "bi car"     "bi cdr"    "bi list" \
         "bi equal"   "bi mapcar"  "bi gensym"\
         "sp and"     "sp or"      "sp eval" \
         "sp quote"   "sp setq"    "sp if"     "sp progn"  "sp let" \
         "sp macro"   "sp lambda"  "sp while"
do
    read t symb name <<< $x
    case $t in
        bi ) type=${TYPE_BI_FUNCTION} ;;
        sp ) type=${TYPE_SPECIAL} ;;
    esac
    bind_symbol $global_env "${TYPE_SYMBOL}${symb}" "${type}${symb}"
    objects[${type}${symb}]="${t}_${name:-$symb}"
done

_next_free_fd () {
    # retvar=$1
    local retvar=$1
    local -i i=3
    while [[ -e /dev/fd/$i ]]; do ((i++)); done
    eval ${retvar}=${i}
}
repl () {
    # inputfd=$1
    local inputfd=$1 terminal
    [[ -z $inputfd ]] && inputfd=0
    [[ -t $inputfd ]] && terminal=true || terminal=false

    _next_free_fd TOK_IN
    eval "exec ${TOK_IN}<&${inputfd}"

    coproc TOK { tokenize <&${TOK_IN}; }

    _next_free_fd TOK_OUT
    eval "exec ${TOK_OUT}<&${TOK[0]}"

    retvar=${PREF_RETVAR}$((_index++))
    while true; do
        $terminal && printf "\n[repl]\n"
        if read_tokens $retvar <&${TOK_OUT}; then
            if eval_expr $retvar $global_env ${!retvar}; then
                print ${!retvar}
            else
                printf "*** COULD NOT EVALUATE EXPRESSION\n"
                _show_error
            fi
        else
            discard_tokens <&${TOK_OUT}
            [[ -z $TOK_PID ]] && break
            printf "*** COULD NOT READ EXPRESSION\n"
            _show_error
            if ! $terminal; then
                kill $TOK_PID
                break
            fi
        fi
        collect
    done

    eval "exec ${TOK_IN}<&-"
    eval "exec ${TOK_OUT}<&-"
}

repl <<_SHLISP_CORE_END_
(progn
  (setq append (lambda (L1 L2)
                 (if (null L1)
                     L2
                   (cons (car L1) (append (cdr L1) L2)))))

  (setq reverse (let ((rev-helper nil))
                  (setq rev-helper (lambda (L R)
                                     (if (null L)
                                         R
                                       (rev-helper (cdr L) (cons (car L) R)))))
                  (lambda (L) (rev-helper L ()))))

  (setq caar (lambda (L)
               (car (car L))))

  (setq cadr (lambda (L)
               (car (cdr L))))

  (setq cdar (lambda (L)
               (cdr (car L))))

  (setq caadr (lambda (L)
                (car (car (cdr L)))))

  (setq cadar (lambda (L)
                (car (cdr (car L)))))

  (setq caddr (lambda (L)
                (car (cdr (cdr L)))))

  (setq not (lambda (p)
              (if p nil T)))

  (setq ${SYMB_BACKQUOTE}
        (let ((bq-helper nil)
              (bq-list nil))
          (setq bq-list (lambda (S tail depth)
                          (if (null S)
                              tail
                            (if (and (consp (car S)) (eq (caar S) '${SYMB_COMMA_AT}))
                                (let ((splicee (if (= depth 1)
                                                  (cadar S)
                                                (list '${SYMB_COMMA_AT} (bq-helper (cadar S) (- depth 1))))))
                                  (bq-list (cdr S) (if (null tail) splicee (list 'append splicee tail)) depth))
                              (bq-list (cdr S) (list 'cons (bq-helper (car S) depth) tail) depth)))))
          (setq bq-helper (lambda (S depth)
                            (if (atom S)
                                (if (symbolp S)
                                    (list 'quote S)
                                  S)
                              (if (eq (car S) '${SYMB_COMMA})
                                  (if (= depth 1)
                                      (cadr S)
                                    (list '${SYMB_COMMA} (bq-helper (cadr S) (- depth 1))))
                                (if (eq (car S) '${SYMB_BACKQUOTE})
                                    (list '${SYMB_BACKQUOTE} (bq-helper (cadr S) (+ depth 1)))
                                  (bq-list (reverse S) () depth))))))
          (macro (S) (bq-helper S 1))))

  (setq defun (macro (fn args . body) \`(setq ,fn (lambda ,args ,@body))))

  (setq defmacro (macro (fn args . body) \`(setq ,fn (macro ,args ,@body))))

  (let ((helper nil))
    (setq helper (lambda (pairs)
                   (if (eq (caar pairs) T)
                       (cadar pairs)
                     (list 'if (caar pairs) (cadar pairs)
                           (if (null (cdr pairs))
                               nil
                             (helper (cdr pairs)))))))
    (defmacro cond pairs (helper pairs)))

  "This is shlisp!")
_SHLISP_CORE_END_

_sourced () { [[ ${FUNCNAME[1]} == 'source' ]]; }
if _sourced; then
    exit
fi

if (($# > 0)); then
    for file in "${@}"; do
        [[ -r $file ]] && repl < "$file" || echo "*** COULD NOT READ FILE $file"
    done
fi

if (($# == 0)) || $_interactive; then
    repl
fi
